/* REXX _sst_new.zrx by the reverend (build 112)                              */
/*-       built by rev-builder version 1.1 on 02 Jan 2003 at 11:11:10        -*/
/*- ------------------------------------------------------------------------ -*/
/*-                       Copyright (C) 2001 Ron Wilson                      -*/
/*-                                                                          -*/
/*- This script is free, and can be modified for your personal use, but you  -*/
/*- cannot copy or distribute this script or any derivative work based upon  -*/
/*- this script without the express permission of the author. Your use of    -*/
/*- this script is governed by the terms of the REV-LICENSE.                 -*/
/*-                                                                          -*/
/*- This program is provided to you WITHOUT ANY WARRANTY, even the implied   -*/
/*- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -*/
/*- REV-LICENSE for more details.                                            -*/
/*-                                                                          -*/
/*-                A copy of the REV-LICENSE is available at:                -*/
/*-       http://thereverend.coastgames.com/tradewars/rev-license.html       -*/
/*- ------------------------------------------------------------------------ -*/
/* rev. 0 - initial release                                                   */

call zoctimeout 300
call zocsynctime 500
globals=_setglobals()
call on halt name _halt

debug=0
oddholds=0
cbscompatible=0

if \_pcheck("Command [") then call _error "please start at the command prompt."

/* get offline information */
   call _newline _ansi("bt;fgr")
   parse value _getgameinfo() with spath ";" iname ";" game
   parse value _getloginfo() with lpath ";" ldefault
   sd=_ini_askint("##DEFAULT##", 0, iname, game, "sd")
   sf=_ini_askint("steal factor?", 70, iname, game, "sf")
   bust_clear=_ini_askint("bust clear frequency?", 1, iname, game, "bust_clear")
   lra=_ini_askstr("##DEFAULT##", 0, iname, game, "last_rob")
   redships=_ini_askstr("##DEFAULT##", "", iname, game, "red_ships")
   cname=_ini_askstr("cim?", "cim", iname, game, "cim")
   mname=lpath||cname||".map"
   bname=lpath||cname||"_bust.txt"
   lname=lpath||cname||"_log.txt"

/* define some variables */
   parse value _getinfo("sect;ship;turns;exp;creds;aln") with csect ";" cship ";" turns ";" exp ";" creds ";" aln
   if aln>-100 then call _error "you must start with at least -100 alignment"
   if turns="##NA##" then turns=9999
   upgcost="250;500;900"
   stamp=""
   hagglemode=_chooselist("haggle?","no haggle;haggle;haggle-jet",";","c")

   call zocsend "'rev-msg : setting up sst^M"

/* read mail and get busts */
   call _read_mail bname, lname
   now=_getservertime("stamp")
   call _getbusts bname, now-bust_clear*86400
   if debug then call _debug "LOG", "BEGIN DEBUG SESSION SST_NEW"

/* pick parking ship */
   call _newline _ansi("bt;fye")
   call zocwriteln "pick a PARKING ship"
   parse value _pickship("what ship to PARK in?", "", "SAFE SHIP;LAST BUST") with parkship "," .

/* get ship list */
   call zocwriteln _ansi("bt;fgr")
   call zocwriteln "pick SST ships -- L=last steal -- B=busted"
   shiplist=_pickships("choose ships to SST with:",redships)
   shipcount=_dwords(shiplist,";")
   call _newline _ansi("bt;fwh")
   call zocwriteln "sh#  sect shiptype"
   do i=1 to shipcount
    shipline=_dword(shiplist,i,";")
    shipnum.i=_dword(shipline,1,",")
    shiploc.i=_dword(shipline,2,",")
    shiptype.i=_dword(shipline,3,",")
    shipname.i=_dword(shipline,4,",")
    shipholds.i=-1
    shipcat.i=_ini_askstr("##DEFAULT##","##NA##",iname,game,"ship."||shiptype.i,"quiet")
    product.i=0
    porttype.i=""
    portquant.i=-1
    ready.i=0
    rangecheck.i=1
    num=shiploc.i
    if _bust.num>0 then busted.i=1
    else busted.i=0
    call zocwrite _pad(shipnum.i,3,"R")
    call zocwrite _pad(shiploc.i,6,"R")
    call zocwriteln " "||shiptype.i busted.i
   end /*do*/

/* check for busted ships */
   do i=1 to shipcount
    if busted.i then do
     if _yesno("you are busted at "||shiploc.i||".  clear this bust and run it anyway?") then do
      if stamp="" then stamp=_getservertime("stamp")
      call _bust_tool "BUST_CLR", shiploc.i, stamp, bname
      busted.i=0
      _bust.i=-stamp
     end /*if*/
    end /*if*/
   end /*do*/

/* get into starting ship - FIRST STEAL */
   menu=""
   shipcounta=0
   do i=1 to shipcount
    select
     when rangecheck.i & \busted.i then do
      menu=menu||";"||copies("  ",3-length(shipnum.i))||shipnum.i
      menu=menu||copies("  ",6-length(shiploc.i))||shiploc.i
      menu=menu||"  "||shiptype.i
      if shipnum.i=cship then menu=menu||" **"
      num=shiploc.i
      if _bust.num>0 then menu=menu||" B"
      if _listin(num,lra) then menu=menu||" L"
      shipcounta=shipcounta+1
     end /*when*/
     when busted.i      then menu=menu||";                    BUSTED"
     when \rangecheck.i then menu=menu||";                    OUT OF RANGE"
     otherwise nop
    end /*select*/
   end /*do*/
   menu=substr(menu,2)
   ans=_drequestlisti("which ship to steal at FIRST?",menu,";","c")
   if cship\=shipnum.ans then do
    call zocsend "x  "||shipnum.ans||"^M  q"
    if zocwait("Choose which ship to beam to (Q=Quit) Q")=640 then call _error "timeout"
    cship=shipnum.ans
    csect=shiploc.ans
    if _getinfo("sect")\=csect then call _error "transport failed."
   end /*if*/
   i=ans

/* start sst */
call zocsend "'rev-msg : starting sst^M"
bustlist=""
done=0
do while \done

 /* if not ready, gather information and dump products */
 if \ready.i then do
  call zocsend "@"
  if zocwait("Average Interval")=640 then call _error "timeout"
  parse value _getinfo("hlds;sect;ore;org;equ") with shipholds.i ";" csect ";" ore ";" org ";" equ
  if shipcat.i="##NA##" then do 
   if _sendwait("c","<Computer activated>")=640 then call _error "timeout"
   call zocreceivebuf(3*1024)
   if _sendwait(";","Photon Missiles")=640 then call _error "timeout"
   if zocwait("(?=Help)?")=640 then call _error "timeout"
   shipcat.i=_parse_ship_desc(translate(zocreceivebuf(0),"  ",d2c(0)||d2c(10)))
   call zocsend "q"
  end /*if*/
  shipmaxholds.i=_dword(shipcat.i,3,";")
  shiprange.i=_dword(shipcat.i,10,";")
  if csect=shiploc.i then do
   call zocsend "d"
   if zocwait("<Re-Display>")=640 then call _error "timeout"
   ans=zocwaitmux("Ports   :","Warps to Sector(s)")
   select
    when ans=0 then nop
    when ans=1 then call _error "no port in this sector"
    when ans=640 then call _error "timeout"
    otherwise nop
   end /*select*/
   if zocwait(")")=640 then call _error "timeout"
   parse value _lastline() with . "(" porttype.i ")"
   product.i=lastpos("B",porttype.i)
   if product.i=0 then call _error "this is not a buy port"
   select
    when product.i=1 & (org>0 | equ>0) then do
     call zocsend "jy"
     shipquant.i=0
    end /*when*/
    when product.i=2 & (ore>0 | equ>0) then do
     call zocsend "jy"
     shipquant.i=0
    end /*when*/
    when product.i=3 & (ore>0 | org>0) then do
     call zocsend "jy"
     shipquant.i=0
    end /*when*/
    otherwise shipquant.i=ore+org+equ
   end /*select*/
   /* pre-furb here */
   do while shipholds.i<shipmaxholds.i
    newholds=_killfurb(7)
    shipholds.i=newholds+shipholds.i
    if newholds=0 then leave
    else call zocsend "'rev-msg : ship "||shipnum.i||" was pre-furbed for "||newholds||" holds^M"
   end /*do*/
   if shipmaxholds.i>shipholds.i then call zocsend "'rev-msg : ship "||shipnum.i||" requires "||shipmaxholds.i-shipholds.i||" holds, using ship anyways^M"
   ready.i=1
  end /*if*/
  else do
   call zocsend "'rev-msg : ship "||shipnum.i||" is not available^M"
   rangecheck.i=0
   shipcounta=shipcounta-1
  end /*else*/
 end /*if*/

 if ready.i then do

  steal=min(trunc(exp/(.3*sf)),shipholds.i)
  if oddholds then do
   if steal//2=0 then steal=steal-1
  end /*if*/

  /*sell*/
  if shipquant.i>0 then do
   select

    when hagglemode="haggle-jet" then do
     call zocreceivebuf 5*1024
     if _sendwait("pt","Trade at this Port")=640 then call _error "timeout"
     tdone=0
     tpmpt.=0
     prodn=_dword("Fuel Ore;Organics;Equipment",product.i,";")
     do while \tdone
      tans=zocwaitmux("Fuel Ore do you want to buy [",,
                      "Organics do you want to buy [",,
                      "Equipment do you want to buy [",,
                      prodn||" do you want to sell [",,
                      "Command [",,
                      "You don't have anything")
      if tans<4 then do
       tpmpt.tans=tpmpt.tans+1
       amount=_stripint(_grabit("]"))
       select
        when tans=0 then call zocsend "15^M"
        when tans=1 then call zocsend "10^M"
        when tans=2 then call zocsend "5^M"
        when tans=3 then call zocsend amount||"^M"
       end /*select*/
       if zocwait("Your offer [")=640 then call _error "timeout"
       offer=_stripint(_grabit("]"))
      end /*if*/
      select
       when tans=0 & tpmpt.tans=1 then trsuccess=_buyhaggle2(offer)
       when tans=1 & tpmpt.tans=1 then trsuccess=_buyhaggle2(offer)
       when tans=2 & tpmpt.tans=1 then trsuccess=_buyhaggle2(offer)
       when tans=3 & tpmpt.tans=1 then trsuccess=_sellhaggle2(offer)
       when tans=4 then tdone=1
       when tans=5 then call _quit "nothing to trade"
       when tans=640 then call _error "timeout"
       otherwise nop
      end /*select*/
     end /*do*/
     buff=zocreceivebuf(0)
     hji=pos("experience point(s).",buff)
     do while hji>0
      exp=exp+substr(buff,hji-2,1)
      hji=pos("experience point(s).",buff,hji+1)
     end /*do*/
     call zocsend "jy"
    end /*when*/

    when hagglemode="haggle" then do
     call zocreceivebuf 5*1024
     if _sendwait("pt","Trade at this Port")=640 then call _error "timeout"
     tdone=0
     tpmpt.=0
     prodn=_dword("Fuel Ore;Organics;Equipment",product.i,";")
     do while \tdone
      tans=zocwaitmux(prodn||" do you want to sell [",,
                      "Command [",,
                      "You don't have anything")
      select
       when tans=0 & \tpmpt.tans then do
        tpmpt.tans=1
        amount=_stripint(_grabit("]"))
        call zocsend amount||"^M"
        if zocwait("Your offer [")=640 then call _error "timeout"
        offer=_stripint(_grabit("]"))
        trsuccess=_sellhaggle2(offer)
        select
         when porttype.i="SSS" then nop
         when porttype.i="SSB" then call zocsend "0^M0^M"
         when porttype.i="SBS" then call zocsend "0^M0^M"
         when porttype.i="BSS" then call zocsend "0^M0^M"
         when porttype.i="SBB" then call zocsend "0^M"
         when porttype.i="BSB" then call zocsend "0^M"
         when porttype.i="BBS" then call zocsend "0^M"
         when porttype.i="BBB" then nop
         otherwise nop
        end /*select*/
       end /*when*/
       when tans=1 then tdone=1
       when tans=2 then call _quit "nothing to trade"
       when tans=640 then call _error "timeout"
       otherwise nop
      end /*select*/
     end /*do*/
     buff=zocreceivebuf(0)
     hji=pos("experience point(s).",buff)
     do while hji>0
      exp=exp+substr(buff,hji-2,1)
      hji=pos("experience point(s).",buff,hji+1)
     end /*do*/
    end /*when*/

    when hagglemode="no haggle" then do
     select
      when porttype.i="SSS" then nop
      when porttype.i="SSB" then call zocsend "pt^M^M0^M0^M"
      when porttype.i="SBS" then call zocsend "pt^M^M0^M0^M"
      when porttype.i="BSS" then call zocsend "pt^M^M0^M0^M"
      when porttype.i="SBB" then call zocsend "pt^M^M0^M"
      when porttype.i="BSB" then call zocsend "pt^M^M0^M"
      when porttype.i="BBS" then call zocsend "pt^M^M0^M"
      when porttype.i="BBB" then call zocsend "pt^M^M"
      otherwise nop
     end /*select*/
    end /*when*/

    otherwise nop

   end /*select*/
   portquant.i=portquant.i+shipquant.i
   shipquant.i=0
  end /*if*/

  /* upgrade for current steal */
  if portquant.i<steal+5 & portquant.i>-1 then do
   upg=_roundup((steal-portquant.i)/10)+1
   call zocsend "o "||copies(product.i||"1^M ",upg)||"q"
  end /*if*/

  /*steal*/
  t_lra=lra
  lra=shiploc.i
  msg="##ZERO##"
  do while msg="##ZERO##" | msg="##HOLDS##"
   parse value _portsteal_fast(steal,product.i) with msg ";" dexp ";" amount ";" portquant.i ";" holds ";" turns ";" fine
   select
    when msg="##SUCCESS##" then do
     exp=exp+dexp
     portquant.i=portquant.i-amount
     shipquant.i=amount
    end /*when*/
    when msg="##BUST##" then do
     num=shiploc.i
     bustlist=bustlist||" "||num
     stamp=_getservertime("stamp")
     call _bust_tool "BUST_ADD", num, stamp, bname
     call _bust_memo "BUST_CLR", num, stamp
     call zocsend "'rev-msg : BUST:real : SHIP:"||_pad(shipnum.i,3,"L")||" : SECT:xx"||shiploc.i//100||" : TURNS:"||turns||" ::^M"
     if cbscompatible then call zocsend "'CMD: Next "||shipnum.i||"^M"
     busted.i=1
     _bust.num=stamp
     shipcounta=shipcounta-1
     shipholds.i=shipholds.i-fine
     do while shipholds.i<shipmaxholds.i
      newholds=_killfurb(7)
      shipholds.i=newholds+shipholds.i
      if newholds=0 then leave
      else call zocsend "'rev-msg : ship "||shipnum.i||" was auto-furbed for "||newholds||" holds^M"
     end /*do*/
     if shipmaxholds.i>shipholds.i then call zocsend "'rev-msg : ship "||shipnum.i||" requires "||shipmaxholds.i-shipholds.i||" holds^M"
    end /*when*/
    when msg="##FAKE##" then do
     lra=t_lra
     call zocsend "'rev-msg : BUST:fake : SHIP:"||_pad(shipnum.i,3,"L")||" : SECT:"||shiploc.i%100||"xx : TURNS:"||turns||" ::^M"
     busted.i=1
     shipcounta=shipcounta-1
     shipholds.i=shipholds.i-fine
     do while shipholds.i<shipmaxholds.i
      newholds=_killfurb(7)
      shipholds.i=newholds+shipholds.i
      if newholds=0 then leave
      else call zocsend "'rev-msg : ship "||shipnum.i||" was auto-furbed for "||newholds||" holds^M"
     end /*do*/
     if shipmaxholds.i>shipholds.i then call zocsend "'rev-msg : ship "||shipnum.i||" requires "||shipmaxholds.i-shipholds.i||" more holds^M"
    end /*when*/
    when msg="##HOLDS##" then do
     lra=t_lra
     /* upgrade port */
     cost=_dword(upgcost,product.i,";")
     if creds<cost*(steal%10+1) then creds=_getinfo("creds")
     upg=min(creds%cost,_roundup((steal-portquant.i)/10)+1)
     if upg>0 then do
      call zocsend "o "||copies(product.i||"1^M ",upg)||"q"
      portquant.i=portquant.i+upg*10
      creds=creds-cost*upg
     end /*if*/
     steal=portquant.i
    end /*when*/
    when msg="##ZERO##" then do
     lra=t_lra
     call _error "stealing zero holds - what's going on?"
    end /*when*/
    otherwise 
   end /*select*/
  end /*do*/

 end /*if*/

 select
  when turns<=15 then done=_yesno("you have "||turns||" turns.  STOP?")
  when turns<30 then nop
  when turns<=32 then done=_yesno("you have "||turns||" turns.  STOP?")
  otherwise nop
 end /*select*/

 /* identify next ship */
 if shipcounta<2 | done then done=1
 else do
  lasti=i
  i=i//shipcount+1
  do while (busted.i | \rangecheck.i) & i\=lasti
   i=i//shipcount+1
  end /*do*/
  if i=lasti then done=1
  else do
   /*transport*/
   call zocsend "x  "||shipnum.i||"^M  q"
  end /*else*/
 end /*else*/

end /*do*/

if \_ini_write(iname,game,"last_rob",lra) then call _error "unable to write to "||iname

select
 when parkship="LAST BUST" then parkship=shipnum.i
 when parkship="SAFE SHIP" then do
  lasti=i
  i=i//shipcount+1
  do while (busted.i | \rangecheck.i) & i\=lasti
   i=i//shipcount+1
  end /*do*/
  parkship=shipnum.i
  call zocsend "x  "||parkship||"^M  q"
 end /*when*/
 otherwise call zocsend "x  "||parkship||"^M  q"
end /*select*/
cship=_getinfo("ship")
call zocsend "'rev-msg : finished sst, parking in ship "||cship||"^M"
if zocwait("Message sent")=640 then call _error "timeout"
if zocwait("(?=Help)? :")=640 then call _error "timeout"
call _quit "busted: "||bustlist
exit

/***                 THE REVEREND'S TW LIBRARY FOR ZOC/REXX                 ***/

/** _setglobals v.3 **/
    _setglobals: procedure expose _verbose _monthdays _monthnames _baseday. (globals)
    
     _verbose=0
     _monthdays="31;28;31;30;31;30;31;31;30;31;30;31"
     _monthnames="jan;feb;mar;apr;may;jun;jul;aug;sep;oct;nov;dec"
     _baseday.2000=730118
     _baseday.2001=_baseday.2000+365+1
     _baseday.2002=_baseday.2001+365
     _baseday.2003=_baseday.2002+365
     _baseday.2004=_baseday.2003+365
     _baseday.2005=_baseday.2004+365+1
     _baseday.2006=_baseday.2005+365
     _baseday.2007=_baseday.2006+365
     _baseday.2008=_baseday.2007+365
    
     rslt="_g. _s. _p. _d. _v. _f. _m. _q. "
     rslt=rslt||"_ef. _es. _et. _ep. "
     rslt=rslt||"_path. _dist. _dtomsl. _dfrmsl. "
     rslt=rslt||"_bg. _nwi. _od. _sv. _pv. _bust. _vs. _vn. "
     rslt=rslt||"_olist1. _olist2. _clvlist1. _clvlist2. "
     rslt=rslt||"_verbose _monthdays _monthnames _baseday. "
     rslt=rslt||"globals reconnect scriptname lra "
     if arg(1,"E") then rslt=rslt||arg(1)
    
     rslt=_space(rslt)
    return rslt

/** _halt v.3 **/
    _halt: procedure expose (globals)
     call off halt
     call zocwriteln "^[[1;33m< user abort >^[[0m "
     exit
    return

/** _pcheck v.4 **/
    _pcheck: procedure expose (globals)
     pc1=arg(1)
     pc2=zocgetscreen(0, zocgetinfo("CURSOR-Y"), zocgetinfo("CURSOR-X"))
     rslt=0
     do i=1 to _dwords(pc1,";")
      if _instr(_dword(pc1,i,";"),pc2,"cs") then rslt=1
     end /*do*/
    return rslt

/** _error v.7 **/
    _error: procedure expose (globals)
     call off halt
     if zocgetinfo("CURSOR-X")>0 then call zocwriteln
     call zocwrite _ansi("bt;frd")||"< script error"
     if arg(1,"E") then call zocwrite ": "||arg(1)
     call zocwriteln " >"
     call zocwriteln _ansi("bt;fye")||"< if this is a serious problem, email me at: the.reverend@coastgames.com > "
     call zocwriteln "< ZOC VERSION '"||zocgetinfo("VERSION")||"', OS '"||zocgetinfo("OSYS")||"', LOCATION '"||zocgetinfo("CONNECTEDTO")||"' >"
     if arg(2,"E") then call zocwriteln _ansi("bt;fgr")||"< "||arg(2)||" >"
     call zocwrite _ansi()
     call _beep "error.wav"
     if reconnect=1 & arg(1)="timeout" then do
      /* call zocdisconnect */
      call zocwriteln _ansi("bt;fwh")||"< ATTEMPTING TO RECONNECT >"
      call zocdostring "^RUN=_connect.zrx sn="||scriptname
     end /*if*/
    exit

/** _newline v.2 **/
    _newline: procedure expose (globals)
     if zocgetinfo("CURSOR-X")>0 then call zocwriteln arg(1)
     else call zocwrite arg(1)
    return

/** _ansi v.3 **/
    _ansi: procedure expose (globals)
     rslt="0"
     do i=1 to _dwords(arg(1),";")
      w=_dword(arg(1),i,";")
      select
       when w="dl"  then rslt=rslt||";"||0  /* dull               */
       when w="bt"  then rslt=rslt||";"||1  /* bright             */
       when w="ul"  then rslt=rslt||";"||4  /* underlined         */
       when w="blk" then rslt=rslt||";"||5  /* blinking           */
       when w="fbk" then rslt=rslt||";"||30 /* black foreground   */
       when w="frd" then rslt=rslt||";"||31 /* red foreground     */
       when w="fgr" then rslt=rslt||";"||32 /* green foreground   */
       when w="fye" then rslt=rslt||";"||33 /* yellow foreground  */
       when w="fbl" then rslt=rslt||";"||34 /* blue foreground    */
       when w="fmg" then rslt=rslt||";"||35 /* magenta foreground */
       when w="fcy" then rslt=rslt||";"||36 /* cyan foreground    */
       when w="fwh" then rslt=rslt||";"||37 /* white foreground   */
       when w="bbk" then rslt=rslt||";"||40 /* black background   */
       when w="brd" then rslt=rslt||";"||41 /* red background     */
       when w="bgr" then rslt=rslt||";"||42 /* green background   */
       when w="bye" then rslt=rslt||";"||43 /* yellow background  */
       when w="bbl" then rslt=rslt||";"||44 /* blue background    */
       when w="bmg" then rslt=rslt||";"||45 /* magenta background */
       when w="bcy" then rslt=rslt||";"||46 /* cyan background    */
       when w="bwh" then rslt=rslt||";"||47 /* white background   */
       otherwise nop
      end /*select*/
     end /*do*/
     rslt="^[["||rslt||"m"
    return rslt

/** _getgameinfo v.5 **/
    _getgameinfo: procedure expose (globals)
     spath=_getscriptpath()
     base=spath||"script.ini"
    
     if arg(1,"E") then fname=arg(1)
     else fname=base
    
     parse value zocgetglobaloption("WindowTitle") with . '="' game '"'
     if fname\=base | game="" | game="%ZOCORHOST% %OPTIONS%" then do
      list=_ini_getheadings(fname)
      if list="##EOF##" then game="##EOF##"
      else do
       templist=""
       do i=1 to _dwords(list,";")
        temp=_dword(list,i,";")
        if left(temp,1)\="*" then do
         if templist="" then templist=temp
         else templist=templist||";"||temp
        end /*if*/
       end /*do*/
       list=templist
       game=_drequestlist("select a game:", list, ";", "c")
      end /*else*/
     end /*do*/
    
     call zocwrite _ansi("bt;fgr")||"< using "
     if length(fname)>17 then call zocwrite "..."
     call zocwriteln right(fname,min(length(fname),17))||" - ["||game||"] >"
    
     rslt=spath||";"||fname||";"||game
    return rslt

/** _getloginfo v.2 **/
    _getloginfo: procedure expose (globals)
     parse value zocgetoption("CaptDefaultName") with . '="' ldefault '"'
     parse value zocgetglobaloption("CapturePath") with . '="' lpath '"'
     lpath=dosfname(lpath)
     if right(lpath,1)\="\" then lpath=lpath||"\"
     if \dosisdir(lpath) then call _error "invalid path in _getloginfo"
     rslt=lpath||";"||ldefault
    return rslt

/** _ini_askint v.5 **/
    _ini_askint: procedure expose (globals)
     if \arg(1,"E") then msg="enter an integer"
     else msg=arg(1)
     do i=2 to 5
      if \arg(i,"E") then call _error "missing parameter in _ini_askint"
     end /*do*/
     default=arg(2)
     fname=arg(3)
     section=arg(4)
     key=arg(5)
     mode=lower(arg(6))
     if _stripint(default)\=default then call _error "invalid parameter in _ini_askint"
     if section="##EOF##" then rslt="##EOF##"
     else rslt=_ini_read(fname, section, key)
     select
      when rslt="##EOF##" & msg="##DEFAULT##" then rslt=_stripint(default)
      when rslt="##EOF##"                     then rslt=_askint(msg||" ("||key||"=)",default,"c")
      when mode="quiet"                       then rslt=_stripint(rslt)
      when mode=""                            then do
       call zocwrite _ansi("bt;fgr")||"< using "
       if length(fname)>17 then call zocwrite "..."
       call zocwriteln right(fname,min(length(fname),17))||" - "||key||"="||rslt||" >"
       rslt=_stripint(rslt)
      end /*when*/
      otherwise nop
     end /*select*/
    return rslt

/** _ini_askstr v.5 **/
    _ini_askstr: procedure expose (globals)
     if \arg(1,"E") then msg="enter a number"
     else msg=arg(1)
     do i=2 to 5
      if \arg(i,"E") then call _error "missing parameter in _ini_askstr"
     end /*do*/
     default=arg(2)
     fname=arg(3)
     section=arg(4)
     key=arg(5)
     mode=lower(arg(6))
     if section="##EOF##" then rslt="##EOF##"
     else rslt=_ini_read(fname, section, key)
     select
      when rslt="##EOF##" & msg="##DEFAULT##" then rslt=default
      when rslt="##EOF##"                     then rslt=_askstr(msg||" ("||key||"=)",default,"c")
      when mode="quiet"                       then nop
      when mode=""                            then do
       call zocwrite _ansi("bt;fgr")||"< using "
       if length(fname)>17 then call zocwrite "..."
       call zocwrite right(fname,min(length(fname),17))||" - "
       call zocwrite key||"="||left(translate(rslt,"~","^"),min(length(rslt),25))
       if length(rslt)>25 then call zocwrite "..."
       call zocwriteln " >"
      end /*when*/
      otherwise nop
     end /*select*/
    return rslt

/** _getinfo v.5 **/
    _getinfo: procedure expose (globals)
     args=lower(arg(1))
     bufflen=3*1024
     call zocreceivebuf bufflen
     call zocsend "/"
     if zocwait("Sect ")=640 then call _error "timeout"
     if zocwait("Ship ")=640 then call _error "timeout"
     if zocwait("^M")=640 then call _error "timeout"
     buff=translate(zocreceivebuf(0),"  ",d2c(10)||d2c(0))
     if length(buff)>=bufflen then call zocwrite "<buffer overflow>"
     i=pos("Sect ",buff)
     j=pos("Ship",buff,i)
     j=pos(d2c(13),buff,j)
     buff=substr(buff,i,j-i)
     buff=_space(translate(buff, "  ;;", d2c(0)||d2c(10)||d2c(13)||d2c(179)),1)
     buff=translate(_space(translate(buff,", "," ,"),0),", "," ,")
    
     vr.=""
     vl.=""
     c=0
     do j=1 to _dwords(buff,";")
      c=c+1
      vr.c=strip(_dword(buff,j,";"))
      vl.c=word(vr.c,2)
      vr.c=lower(word(vr.c,1))
      if vr.c="ship" then do
       c=c+1
       vr.c=strip(_dword(buff,j,";"))
       vl.c=word(vr.c,3)
       vr.c="shiptype"
      end /*if*/
     end /*do*/
    
     rslt=""
     do i=1 to _dwords(args,";")
      found=0
      do j=1 to c
       if vr.j=_dword(args,i,";") then do
        rslt=rslt||";"||vl.j
        found=1
       end /*if*/
      end /*do*/
      if \found then rslt=rslt||";"||"##NA##"
     end /*do*/
     if rslt\="" then rslt=substr(rslt,2)
    
    return rslt

/** _chooselist v.6 **/
    _chooselist: procedure expose (globals)
     prompt=arg(1)
     list=arg(2)
     if list="" then call _error "no list"
     delim=arg(3)
     if delim="" then delim=" "
     if length(delim)>1 then call _error "long delimiter"
    
     ch.=""
     i=_dwords(list,delim)
     do j=1 to i
      ch.j=_dword(list,j,delim)
     end /*do*/
    
     if i<7 then max=1
     if i<5 then max=0
     if i>=7 then max=(i-5)%2+1
    
     done=0
     loc=0
     do while \done
      if loc<0 then loc=0
      if loc>max then loc=max
    
      select
       when loc=0 then do
        if max=0 then rslt=zocrequest(prompt, ch.1, ch.2, ch.3, ch.4)
        else rslt=zocrequest(prompt, ch.1, ch.2, ch.3, "next")
       end /*when*/
       when loc=max then do
        p1=(loc-1)*2+4
        p2=p1+1
        p3=p1+2
        rslt=zocrequest(prompt, "back", ch.p1, ch.p2, ch.p3)
       end /*when*/
       otherwise do
        p1=(loc-1)*2+4
        p2=p1+1
        rslt=zocrequest(prompt, "back", ch.p1, ch.p2, "next")
       end /*otherwise*/
      end /*select*/
    
      select
       when rslt="next" then loc=loc+1
       when rslt="back" then loc=loc-1
       when rslt="##CANCEL##" then done=1
       when rslt="" then nop
       otherwise done=1
      end /*select*/
    
     end /*do*/
    
     if lower(arg(4))="c" & rslt="##CANCEL##" then call _quit "script cancelled by user.", "nocopy"
    
    return rslt

/** _read_mail v.2 **/
    _read_mail: procedure expose (globals)
     if \arg(1,"E") | \arg(2,"E") then call _error "missing parameter in _read_mail"
     bname=arg(1)
     lname=arg(2)
     if _sendwait("cm","<Read messages>")=640 then call _error "timeout"
     done=0
     pflag=1
     lg_i=0
     do while \done
      ans=zocwaitmux("[Pause]",,
                     "No messages received.",,
                     "> ",,
                     "::",,
                     "/14:",,
                     "/15:",,
                     "entered sector.",,
                     "Sub Space Ether Probe.",,
                     "I.D. code.",,
                     "Delete messages? (Y/N) [N]")
      select
       when ans=0 then do
        call zocdelay 1
        select
         when _pcheck("[Pause] - [") & pflag then do
          call zocsend " "
          pflag=0
         end /*when*/
         when _pcheck("[Pause] - [") then nop
         when _pcheck("[Pause] - D") then do
          call zocsend "y"
          done=1
         end /*when*/
         otherwise do
          call zocsend " "
          pflag=0
         end /*otherwise*/
        end /*select*/
       end /*when*/
       when ans=1 then do
        call zocsend " "
        done=1
       end /*when */
       when ans=2 & \pflag then pflag=1
       when ans=2 then nop
       when ans=3 then do
        line=_lastline()
        parse var line brand "-" typ " : " cmd . sect . stamp .
        if typ="CMD" then call _bust_tool cmd, sect, stamp, bname, lg_name
       end /*when*/
       when ans<=5 then do
        line=_lastline()
        parse var line "Received from " lg_name " at " lg_hr ":" lg_mn ":" lg_sc lg_ampm " S.D. " lg_ds ":"
        if lg_ampm="PM" then lg_hr=lg_hr+12
        lg_ts=lg_hr||":"||lg_mn||":"||lg_sc
        lg_stamp=lg_ds||", "||lg_ts
       end /*when*/
       when ans=6 then do /* entered sector. */
        line=_lastline()
        parse var line . "Sector " lg_sect ": " lg_name " entered sector."
        lg_i=lg_i+1
        lg_list.lg_i=_pad(lg_sect,5,"L")||": "||lg_stamp||" - ENTER "||lg_name
       end /*when*/
       when ans=7 then do /* probe */
        line=_lastline()
        parse var line . "sector " lg_sect .
        pflag=1
       end /*when*/
       when ans=8 then do /* probe traced */
        line=_lastline()
        parse var line . "to " lg_name "'s I.D. code." .
        lg_i=lg_i+1
        lg_list.lg_i=_pad(lg_sect,5,"L")||": "||lg_stamp||" - PROBE "||lg_name
       end /*when*/
       when ans=9 then do
        call zocsend "y"
        done=1
       end /*when*/
       otherwise nop
      end /*select*/
     end /*do*/
     call zocsend "q"
     if zocwait("(?=Help)? :")=640 then call _error "timeout"
     if _fileopenw(lname) then do
      do i=1 to lg_i
       call lineout lname, lg_list.i
      end /*do*/
      call _fileclose lname
     end /*if*/
    return

/** _getservertime v.7 **/
    _getservertime: procedure expose (globals)
    
     /* get real date/time values */
        parse value date("N") with . . year
        parse value date("O") with . "/" month "/" day
        sod=time("S")
        doy=date("D")
        base=date("B")
        parse value time("N") with hr ":" mn ":" sc
        leapyear=abs((year//4=0)-1)
        base=base-_baseday.2000
        base_sec=base*86400+sod
    
     /* get game date/time values */
        if _g.!timediff="_G.!TIMEDIFF" then do
         if _sendwait("ct","(?=Help)? T")=640 then call _error "timeout"
         if zocwaitmux(", "||year+11, ", "||year+12, ", "||year+13)=640 then call _error "timeout"
         line=_lastline()
         call zocsend "q"
         parse var line g_hr ":" g_min ":" g_sec g_ampm . g_month g_day ", " g_year .
         g_year=g_year-12
         if g_ampm="PM" & g_hr\=12 then g_hr=g_hr+12
         g_month=lower(g_month)
         do i=12 to 1 by -1
          if g_month=_dword(_monthnames,i,";") then leave
         end /*do*/
         g_month=i
         parse value _calc_base_date(g_year, g_month, g_day, g_hr, g_min, g_sec) with g_base ";" g_doy ";" g_sod ";" g_base_sec
         _g.!timediff=base_sec-g_base_sec
        end /*if*/
        else do
         g_base_sec=base_sec-_g.!timediff
         g_sod=g_base_sec//86400
         g_base=g_base_sec%86400
         do i=2000 to 2008
          if (_baseday.i-_baseday.2000)<=g_base then g_year=i
         end /*do*/
         g_doy=g_base-_baseday.g_year+_baseday.2000
        end /*else*/
    
     select
      when arg(1)="seconds"   then rslt=g_sod
      when arg(1)="minutes"   then rslt=g_sod%60
      when arg(1)="hours"     then rslt=g_sod%3600
      when arg(1)="stamp_old" then rslt=g_year-2000||copies("0",3-length(g_doy))||g_doy||copies("0",5-length(g_sod))||g_sod
      when arg(1)="stamp"     then rslt=g_base_sec
      otherwise                    rslt=g_base_sec
     end /*select*/
    return rslt

/** _getbusts v.2 **/
    _getbusts: procedure expose (globals)
     fname=arg(1)
     if arg(2,"E") then safedate=arg(2)
                   else safedate=0
     _bust.=0
     max=0
    
     if _fileopenr(fname) then do
      do while \_fileeof(fname)
       line=linein(fname)
       parse var line cmd . sector . stamp .
       if lower(sector)\="all" & sector\="" then max=max(max,sector)
       select
        when cmd="BUST_CLR" & (lower(sector)="all" | sector=0) then do
         do i=1 to max
          if stamp>abs(_bust.i) & _bust.i\=0 then _bust.i=-stamp
         end /*do*/
        end /*when*/
        when abs(_bust.sector)>stamp then nop
        when cmd="BUST_ADD" & safedate=0     then _bust.sector=stamp
        when cmd="BUST_ADD" & safedate>stamp then _bust.sector=-stamp
        when cmd="BUST_CLR"                  then _bust.sector=-stamp
        otherwise nop
       end /*select*/
      end /*do*/
      call _fileclose fname
     end /*if*/
    
     call _newline _ansi("bt;fwh")
     call zocwriteln "BUST LIST:"
     count=0
     earliest=999999999
     do i=1 to max
      if _bust.i>0 then do
       count=count+1
       call zocwrite _pad(i,6,"R")
       earliest=min(earliest,_bust.i)
       if count//12=0 then call zocwriteln
      end /*if*/
     end /*do*/
     if count//12>0 then call zocwriteln
    
    return earliest

/** _debug v.5 **/
    _debug: procedure expose (globals)
     if \arg(1,"E") | \arg(2,"E") then call _error "missing parameter in _debug"
     mode=strip(left(lower(arg(1)),3))
     msg=arg(2)
     if arg(3,"E") then logname=strip(arg(3))
     else logname="_debug.txt"
     select
      when mode="scr" then call zocwriteln "^[[1;34mREV-DEBUG <"||msg||">^[[0m"
      when mode="fed" then call zocsend "`REV-DEBUG <"||msg||">^M"
      when mode="sub" then call zocsend "'REV-DEBUG <"||msg||">^M"
      when mode="log" then do
       if _fileopenw(logname) then do
        call lineout logname, msg
        call _fileclose logname
       end /*if*/
       else call _error "unable to open rev-log.txt."
      end /*when*/
      otherwise nop
     end /*select*/
    return

/** _pickship v.3 **/
    _pickship: procedure expose (globals)
     msg=arg(1)
     if msg="" then msg="choose ships:"
     shiplist=arg(2)
     premenu=arg(3)
     buflen=16*1024
    
     /* get current ship from CZQ list */
     call zocreceivebuf buflen
     call zocsend "czq"
     if zocwait("<Active Ship Scan>")=640 then call _error "timeout"
     if zocwait("(?=Help)? :")=640 then call _error "timeout"
     buff=translate(zocreceivebuf(0),"  ",d2c(0)||d2c(10))
     if length(buff)=buflen then call _error "buffer overflow"
     i=pos("----------",buff)
     if i>0 then i=pos(d2c(13),buff,i)+1
     if i>1 then j=pos(d2c(13),buff,i)
     c=0
     do while i>0 & j>0
      line=strip(substr(buff,i,j-i))
      if line="" then leave
      parse var line shipnum shiploc
      if pos("+",shiploc)>0 then do
       c=c+1
       plus=pos("+",line)
       current.c=1
       line=left(line,plus-1)||" "||substr(line,plus+1)
       parse var line shipnum.c shiploc.c line
       shipname.c=left(line,20)
       line=substr(line,21)
       if right(shipname.c,4)="Corp" then shipname.c=left(shipname.c,length(shipname.c)-5)
       parse var line figs.c shields.c hops.c shiptype.c
       shipname.c=strip(shipname.c)
       shiptype.c=strip(shiptype.c)
       if pos("T",figs.c)>0 then figs.c=strip(translate(figs.c," ", "T"))*1000
       if pos("T",shields.c)>0 then shields.c=strip(translate(shields.c," ", "T"))*1000
       if shiplist\="" then do
        found=0
        do k=1 to _dwords(shiplist,";")
         if pos(lower(_dword(shiplist,k,";")),lower(shiptype.c))>0 then found=1
         if found then leave
        end /*do*/
        if \found then c=c-1
       end /*if*/
      end /*if*/
      i=j+1
      j=pos(d2c(13),buff,i)
     end /*do*/
    
     /* get ships from XQ */
     call zocreceivebuf buflen
     call zocsend "x^Mzqzn"
     if zocwait("<Transport to Ship>")=640 then call _error "timeout"
     if zocwait("(?=Help)? :")=640 then call _error "timeout"
     buff=translate(zocreceivebuf(0),"  ",d2c(0)||d2c(10))
     if length(buff)=buflen then call _error "buffer overflow"
     i=pos("----------",buff)
     if i>0 then i=pos(d2c(13),buff,i)+1
     if i>1 then j=pos(d2c(13),buff,i)
     do while i>0 & j>0
      line=strip(substr(buff,i,j-i))
      if line="" then leave
      c=c+1
      current.c=0
      parse var line shipnum.c shiploc.c line
      shipname.c=left(line,20)
      line=substr(line,21)
      if right(shipname.c,4)="Corp" then shipname.c=left(shipname.c,length(shipname.c)-5)
      parse var line figs.c shields.c hops.c shiptype.c
      shipname.c=strip(shipname.c)
      shiptype.c=strip(shiptype.c)
      if pos("T",figs.c)>0 then figs.c=strip(translate(figs.c," ", "T"))*1000
      if pos("T",shields.c)>0 then shields.c=strip(translate(shields.c," ", "T"))*1000
      if shiplist\="" then do
       found=0
       do k=1 to _dwords(shiplist,";")
        if pos(lower(_dword(shiplist,k,";")),lower(shiptype.c))>0 then found=1
        if found then leave
       end /*do*/
       if \found then c=c-1
      end /*if*/
      i=j+1
      j=pos(d2c(13),buff,i)
     end /*do*/
    
     /* sort ship list by ship number */
     do i=1 to c
      do j=i+1 to c
       if shipnum.i>shipnum.j then do
        temp=shipnum.i
        shipnum.i=shipnum.j
        shipnum.j=temp
        temp=shiploc.i
        shiploc.i=shiploc.j
        shiploc.j=temp
        temp=shipname.i
        shipname.i=shipname.j
        shipname.j=temp
        temp=shiptype.i
        shiptype.i=shiptype.j
        shiptype.j=temp
        temp=figs.i
        figs.i=figs.j
        figs.j=temp
        temp=shields.i
        shields.i=shields.j
        shields.j=temp
        temp=current.i
        current.i=current.j
        current.j=temp
       end /*if*/
      end /*do*/
     end /*do*/
    
     /* pick ships */
     menu=""
     pmc=_dwords(premenu,";")
     if premenu\="" then do
      do i=1 to pmc
       menu=menu||";                    "||_dword(premenu,i,";")
      end /*do*/
     end /*if*/
     do i=1 to c
      menu=menu||";"||_pad(shipnum.i,3,"R")
      menu=menu||_pad(shiploc.i,6,"R")
      menu=menu||"  "||shiptype.i
      if current.i then menu=menu||" **"
      num=shiploc.i
      if _bust.num>0 then menu=menu||" B"
      if num=lra then menu=menu||" L"
     end /*do*/
     menu=substr(menu,2)
     i=_drequestlisti(msg,menu,";","c")
     if i<=pmc then rslt=_dword(premenu,i,";")
     else do
      j=i-pmc
      rslt=shipnum.j||","||shiploc.j||","||shiptype.j||","||shipname.j
     end /*else*/
    return rslt

/** _pickships v.4 **/
    _pickships: procedure expose (globals)
     msg=arg(1)
     if msg="" then msg="choose ships:"
     shiplist=arg(2)
     buflen=16*1024
    
     /* get current ship from CZQ list */
     call zocreceivebuf buflen
     call zocsend "czq"
     if zocwait("<Active Ship Scan>")=640 then call _error "timeout"
     if zocwait("(?=Help)? :")=640 then call _error "timeout"
     buff=translate(zocreceivebuf(0),"  ",d2c(0)||d2c(10))
     if length(buff)=buflen then call _error "buffer overflow"
     i=pos("----------",buff)
     if i>0 then i=pos(d2c(13),buff,i)+1
     if i>1 then j=pos(d2c(13),buff,i)
     c=0
     do while i>0 & j>0
      line=strip(substr(buff,i,j-i))
      if line="" then leave
      parse var line shipnum shiploc
      if pos("+",shiploc)>0 then do
       c=c+1
       plus=pos("+",line)
       current.c=1
       line=left(line,plus-1)||" "||substr(line,plus+1)
       parse var line shipnum.c shiploc.c line
       shipname.c=left(line,20)
       line=substr(line,21)
       if right(shipname.c,4)="Corp" then shipname.c=left(shipname.c,length(shipname.c)-5)
       parse var line figs.c shields.c hops.c shiptype.c
       shipname.c=strip(shipname.c)
       shiptype.c=strip(shiptype.c)
       if pos("T",figs.c)>0 then figs.c=strip(translate(figs.c," ", "T"))*1000
       if pos("T",shields.c)>0 then shields.c=strip(translate(shields.c," ", "T"))*1000
       if shiplist\="" then do
        found=0
        do k=1 to _dwords(shiplist,";")
         if pos(lower(strip(_dword(shiplist,k,";"))),lower(shiptype.c))>0 then found=1
         if found then leave
        end /*do*/
        if \found then c=c-1
       end /*if*/
      end /*if*/
      i=j+1
      j=pos(d2c(13),buff,i)
     end /*do*/
    
     /* get ships from XQ */
     call zocreceivebuf buflen
     call zocsend "x^Mzqzn"
     if zocwait("<Transport to Ship>")=640 then call _error "timeout"
     if zocwait("(?=Help)? :")=640 then call _error "timeout"
     buff=translate(zocreceivebuf(0),"  ",d2c(0)||d2c(10))
     if length(buff)=buflen then call _error "buffer overflow"
     i=pos("----------",buff)
     if i>0 then i=pos(d2c(13),buff,i)+1
     if i>1 then j=pos(d2c(13),buff,i)
     do while i>0 & j>0
      line=strip(substr(buff,i,j-i))
      if line="" then leave
      c=c+1
      current.c=0
      parse var line shipnum.c shiploc.c line
      shipname.c=left(line,20)
      line=substr(line,21)
      if right(shipname.c,4)="Corp" then shipname.c=left(shipname.c,length(shipname.c)-5)
      parse var line figs.c shields.c hops.c shiptype.c
      shipname.c=strip(shipname.c)
      shiptype.c=strip(shiptype.c)
      if pos("T",figs.c)>0 then figs.c=strip(translate(figs.c," ", "T"))*1000
      if pos("T",shields.c)>0 then shields.c=strip(translate(shields.c," ", "T"))*1000
      if shiplist\="" then do
       found=0
       do k=1 to _dwords(shiplist,";")
        if pos(lower(_dword(shiplist,k,";")),lower(shiptype.c))>0 then found=1
        if found then leave
       end /*do*/
       if \found then c=c-1
      end /*if*/
      i=j+1
      j=pos(d2c(13),buff,i)
     end /*do*/
    
     /* sort ship list by ship number */
     do i=1 to c
      do j=i+1 to c
       if shipnum.i>shipnum.j then do
        temp=shipnum.i
        shipnum.i=shipnum.j
        shipnum.j=temp
        temp=shiploc.i
        shiploc.i=shiploc.j
        shiploc.j=temp
        temp=shipname.i
        shipname.i=shipname.j
        shipname.j=temp
        temp=shiptype.i
        shiptype.i=shiptype.j
        shiptype.j=temp
        temp=figs.i
        figs.i=figs.j
        figs.j=temp
        temp=shields.i
        shields.i=shields.j
        shields.j=temp
        temp=current.i
        current.i=current.j
        current.j=temp
       end /*if*/
      end /*do*/
     end /*do*/
    
     /* pick ships */
     menu=""
     do i=1 to c
      menu=menu||";"||_pad(shipnum.i,3,"R")
      menu=menu||_pad(shiploc.i,6,"R")
      menu=menu||"  "||shiptype.i
      if current.i then menu=menu||" **"
      num=shiploc.i
      if _bust.num>0 then menu=menu||" B"
      if num=lra then menu=menu||" L"
     end /*do*/
     menu=substr(menu,2)
     ans=_mrequestlist(msg,menu,";","c")
     rslt=""
     do i=1 to c
      if _dword(ans,i,";") then rslt=rslt||";"||shipnum.i||","||shiploc.i||","||shiptype.i||","||shipname.i
     end /*do*/
     rslt=substr(rslt,2)
    return rslt

/** _dwords v.2 **/
    _dwords: procedure expose (globals)
     rslt=words(translate(arg(1),arg(2)||" "," "||arg(2)))
    return rslt

/** _dword v.2 **/
    _dword: procedure expose (globals)
     rslt=translate(word(translate(arg(1),arg(3)||" "," "||arg(3)),arg(2))," "||arg(3),arg(3)||" ")
    return rslt

/** _pad v.1 **/
    _pad: procedure expose (globals)
     rslt=arg(1)
     if arg(2,"E") then w=arg(2); else return rslt
     if \arg(3,"E") then m="L"; else m=arg(3)
     select
      when m="L" then rslt=left(rslt,w)
      when m="R" then rslt=reverse(left(reverse(rslt),w))
      when m="C" then rslt=center(rslt,w)
      otherwise       rslt=left(rslt,w)
     end /*select*/
    return rslt

/** _yesno v.3 **/
    _yesno: procedure expose (globals)
     if arg(1,"E") then msg=arg(1)
     else msg="yes or no"
     if arg(2)="yn" then rslt=zocrequest(msg||" (ESC=no)", "yes", "no")
                    else rslt=zocrequest(msg, "yes", "no", "cancel")
     select
      when rslt="cancel" then call _quit "script cancelled by user.", "nocopy"
      when rslt="##CANCEL##" & arg(2)\="yn" then call _quit "script cancelled by user.", "nocopy"
      when rslt="yes" then rslt=1
      otherwise rslt=0
     end /*select*/
    return rslt

/** _bust_tool v.1 **/
    _bust_tool: procedure expose (globals)
     cmd=arg(1)
     sector=arg(2)
     stamp=arg(3)
     fname=arg(4)
     note=arg(5)
     msg=cmd||" : "||_pad(sector,5,"R")||" : "||stamp
     if note\="" then msg=msg||" : "||note
     if _fileopenw(fname) then do
      call lineout fname, msg
      call _fileclose fname
     end /*if*/
     else call _error "unable to open file "||fname||"."
    return

/** _listin v.3 **/
    _listin: procedure expose (globals)
     if \arg(1,"E") | \arg(2,"E") then call _error "missing parameter in _listin"
     find=arg(1)
     list=arg(2)
     if arg(3,"E") then delim=left(arg(3),1)
                   else delim=";"
     rslt=0
     do i=1 to _dwords(list,delim)
      if find==_dword(list,i,delim) then do
       rslt=1
       leave
      end /*if*/
     end /*do*/
    return rslt

/** _drequestlisti v.2 **/
    _drequestlisti: procedure expose (globals)
     do i=1 to 3
      if \arg(i,"E") then call _error "missing parameter in _drequestlisti"
     end /*do*/
     i=zocrequestlist(arg(1),translate(arg(2),"|"||arg(3),arg(3)||"|"))
     if i<0 & lower(arg(4))="c" then call _quit "script cancelled by user.", "nocopy"
                                else rslt=i+1
    return rslt

/** _sendwait v.1 **/
    _sendwait: procedure expose (globals)
     if \arg(1,"E") | \arg(2,"E") then call _error "missing parameter in _sendwait"
     call zocsend arg(1)
     rslt=zocwait(arg(2))
     select
      when \arg(3,"E") | arg(3)=""             then nop
      when lower(arg(3))="timeout"  & rslt=640 then call _error "timeout"
      when lower(arg(3))="lastline" & rslt=640 then call _error "timeout"
      when lower(arg(3))="lastline"            then rslt=_lastline()
      otherwise nop
     end /*select*/
    return rslt

    /* _parse_ship_desc v.1 */
    _parse_ship_desc:  procedure expose (globals)
     buff=arg(1)
     rslt=""
    
     i=pos("Basic Hold Cost:",buff)
     j=pos(d2c(13),buff,i)
     line.1=strip(substr(buff,i,j-i))
     parse var line.1 ":" basicholdcost . ":" initialholds . ":" maximumshields .
     basicholdcost=_stripcomma(strip(basicholdcost))
     maximumshields=_stripcomma(strip(maximumshields))
    
     i=pos("Main Drive Cost:",buff,j+1)
     j=pos(d2c(13),buff,i)
     line.2=strip(substr(buff,i,j-i))
     parse var line.2 ":" maindrivecost . ":" maxfighters . ":" offensiveodds .
     maindrivecost=_stripcomma(strip(maindrivecost))
     maxfighters=_stripcomma(strip(maxfighters))
     offensiveodds=_dword(strip(offensiveodds),1,":")
    
     i=pos("Computer Cost:",buff,j+1)
     j=pos(d2c(13),buff,i)
     line.3=strip(substr(buff,i,j-i))
     parse var line.3 ":" computercost . ":" turnsperwarp . ":" defensiveodds .
     computercost=_stripcomma(strip(computercost))
     defensiveodds=_dword(strip(defensiveodds),1,":")
    
     i=pos("Ship Hull Cost:",buff,j+1)
     j=pos(d2c(13),buff,i)
     line.4=strip(substr(buff,i,j-i))
     parse var line.4 ":" shiphullcost . ":" minemax . ":" beaconmax .
     shiphullcost=_stripcomma(strip(shiphullcost))
     minemax=strip(minemax)
     beaconmax=strip(beaconmax)
    
     i=pos("Ship Base Cost:",buff,j+1)
     j=pos(d2c(13),buff,i)
     line.5=strip(substr(buff,i,j-i))
     parse var line.5 ":" shipbasecost . ":" genesismax . ":" longrangescan .
     shipbasecost=_stripcomma(strip(shipbasecost))
     genesismax=strip(genesismax)
     longrangescan=pos("Y",strip(longrangescan))
    
     i=pos("Max Figs Per Attack:",buff,j+1)
     j=pos(d2c(13),buff,i)
     line.6=strip(substr(buff,i,j-i))
     parse var line.6 ":" maxfigsperattack . ":" transwarpdrive . ":" planetscanner .
     maxfigsperattack=_stripcomma(strip(maxfigsperattack))
     transwarpdrive=pos("Y",strip(transwarpdrive))
     planetscanner=pos("Y",strip(planetscanner))
    
     i=pos("Maximum Holds:",buff,j+1)
     j=pos(d2c(13),buff,i)
     line.7=strip(substr(buff,i,j-i))
     parse var line.7 ":" maximumholds . ":" transportrange . ":" photonmissiles .
     maximumholds=strip(maximumholds)
     transportrange=strip(transportrange)
     photonmissiles=pos("Y",strip(photonmissiles))
    
     rslt=shipbasecost maxfigsperattack maximumholds initialholds maxfighters turnsperwarp minemax genesismax ,
          transwarpdrive transportrange maximumshields offensiveodds defensiveodds beaconmax longrangescan ,
          planetscanner photonmissiles
     rslt=translate(rslt,";"," ")
    
    return rslt
    
    /*
    
    Which ship are you interested in (?=List) ?
    You shut off the Vid Term.
    
    Computer command [TL=00:00:00]:[3156] (?=Help)? ;
    
                                  Corporate FlagShip
    
         Basic Hold Cost:   10,000   Initial Holds:     20 Maximum Shields: 1,500
         Main Drive Cost:    5,000    Max Fighters: 20,000  Offensive Odds: 1.2:1
           Computer Cost:  120,000  Turns Per Warp:      3  Defensive Odds: 1.2:1
          Ship Hull Cost:   28,500        Mine Max:    100      Beacon Max:   100
          Ship Base Cost:  163,500     Genesis Max:     10 Long Range Scan:   Yes
     Max Figs Per Attack:     6000 TransWarp Drive:    Yes  Planet Scanner:   Yes
           Maximum Holds:       85 Transport Range:     10 Photon Missiles:    No
    
    Computer command [TL=00:00:00]:[3156] (?=Help)?
    */

/** _lastline v.3 **/
    _lastline: procedure expose (globals)
     rslt=zoclastline()
     select
      when lower(arg(1))="raw" then nop
      when pos(d2c(7),rslt)>0  then rslt=translate(zocstring("REMOVE", rslt, d2c(7)),"  ",d2c(0)||d2c(10))
      otherwise                     rslt=translate(rslt,"  ",d2c(0)||d2c(10))
     end /*select*/
    return rslt

/** _killfurb v.1 **/
    _killfurb: procedure expose (globals)
     figs=arg(1)
     holds=arg(2)
     if holds="" then holds=_getinfo("hlds")
     call zocsend "a"
     if zocwait("<Attack>")=640 then call _error "timeout"
     ans=zocwaitmux(") (Y/N)","(?=Help)? :")
     do while ans=0
      line=_lastline()
      i=lastpos("-",line)+1
      j=pos(")",line,i)
      furbfigs=_space(translate(substr(line,i,j-i)," ",","),0)
      select
       when pos("]'s",line)>0 then call zocsend "n"
       when furbfigs=0 then leave
       otherwise call zocsend "n"
      end /*select*/
      ans=zocwaitmux(") (Y/N)","(?=Help)? :")
     end /*do*/
     select
      when ans=0 then do
       call zocsend "y"||figs||"^M"
       rslt=_getinfo("hlds")-holds
      end /*when*/
      when ans=1 then rslt=0
      when ans=640 then call _error "timeout"
      otherwise nop
     end /*select*/
    return rslt

/** _stripint v.4 **/
    _stripint: procedure expose (globals)
     mask=_space(translate(arg(1)," ","-0123456789"," "),0)
     rslt=_space(translate(arg(1)," ",mask," "),0)
     if left(rslt,1)="-" then rslt="-"||_space(translate(rslt," ","-"),0)
     else rslt=_space(translate(rslt," ","-"),0)
     if \datatype(rslt,"W") then rslt=""
    return rslt

/** _grabit v.2 **/
    _grabit: procedure expose (globals)
     if zocwait(arg(1))=640 then call _error "timeout"
     rslt=_lastline()
     if lower(arg(2))="s" then rslt=reverse(substr(reverse(rslt),length(arg(1))))
    return rslt

/** _buyhaggle2 v.2 **/
    _buyhaggle2: procedure expose (globals)
     portoffer=arg(1)
     offer=trunc(portoffer/1.06)
    
     success=1
    
     call zocsend offer||"^M"
     iter=1
    
     done=0
     do while \done
    
      ans=zocwaitmux("We'll sell them for",,
                     "Our final offer",,
                     "We're not interested.",,
                     "You have")
      select
    
       when ans=0 then do
        if zocwait("Your offer [")=640 then call _error "timeout"
        newportoffer=_stripint(_grabit("]"))
        iter=iter+1
        newoffer=trunc(offer*max(1.003,(newportoffer/portoffer)))
        if newoffer<=offer then newoffer=offer+1
        offer=newoffer
        portoffer=newportoffer
        call zocsend offer||"^M"
       end /*when*/
    
       when ans=1 then do
        if zocwait("Your offer [")=640 then call _error "timeout"
        finalportoffer=_stripint(_grabit("]"))
        iter=iter+1
        factor=0.5
        if iter<3 then factor=0.6
        offer=trunc(offer*(1-factor) + finalportoffer*factor)
        call zocsend offer||"^M"
       end /*when*/
    
       when ans=2 then do
        done=1
        success=0
       end /*when*/
    
       when ans=3 then done=1
    
       when ans=640 then call _error "timeout"
    
       otherwise nop
    
      end /*select*/
    
     end /*while*/
    
    return success

/** _sellhaggle2 v.2 **/
    _sellhaggle2: procedure expose (globals)
     portoffer=arg(1)
     offer=trunc(portoffer*1.06)
    
     success=1
     iter=1
    
     call zocsend offer||"^M"
    
     done=0
     do while \done
    
      ans=zocwaitmux("We'll buy them for", ,
                       "Our final offer", ,
                       "We're not interested.", ,
                       "You have")
      select
    
       when ans=0 then do
        if zocwait("Your offer [")=640 then call _error "timeout"
        if zocwait("]")=640 then call _error "timeout"
        newportoffer=_stripint(_lastline())
        iter=iter+1
        newoffer=trunc(offer/max(1.003,(newportoffer/portoffer)))
        if newoffer>=offer then newoffer=offer-1
        offer=newoffer
        portoffer=newportoffer
        call zocsend offer||"^M"
       end /*when*/
    
       when ans=1 then do
        if zocwait("Your offer [")=640 then call _error "timeout"
        if zocwait("]")=640 then call _error "timeout"
        finalportoffer=_stripint(_lastline())
        iter=iter+1
        factor=0.5
        if iter<3 then factor=0.6
        offer=trunc(offer*(1-factor) + finalportoffer*factor)
        call zocsend offer||"^M"
       end /*when*/
    
       when ans=2 then do
        done=1
        success=0
       end /*when*/
    
       when ans=3 then do
        done=1
       end /*when*/
    
       when ans=640 then call _error "timeout"
    
       otherwise nop
    
      end /*select*/
    
     end /*while*/
    
    return success

/** _quit v.7 **/
    _quit: procedure expose (globals)
     lcpy=1
     arg1=""
     do i=1 to 2 /* manage arguments */
      select
       when arg(i,"E") & lower(arg(i))="nocopy" then lcpy=0
       when arg(i,"E") & arg1="" then arg1=arg(i)
       otherwise nop
      end /*select*/
     end /*do*/
     line=zocgetscreen(0, zocgetinfo("CURSOR-Y"), zocgetinfo("CURSOR-X"))
     select /* define message */
      when  lcpy & arg1="" then msg="^[[1;32m< end script >^[[0m^M^J"||line
      when \lcpy & arg1="" then msg="^[[1;32m< end script >^[[0m "
      when  lcpy           then msg="^[[1;32m^M^J< end script: "||arg1||" >^[[0m^M^J"||line
      when \lcpy           then msg="^[[1;32m^M^J< end script: "||arg1||" >^[[0m "
      otherwise nop
     end /*select*/
     call zocwrite msg
     select /* choose a beep */
      when lower(arg1)="script cancelled by user." then call _beep "cancel.wav"
      otherwise call _beep "quit.wav"
     end /*select*/
     exit
    return 1

/** _roundup v.2 **/
    _roundup: procedure expose (globals)
     if arg(1,"E") then num=arg(1)
     else call _error "missing parameter in _roundup"
     if arg(2,"E") then digits=arg(2)
     else digits=0
     num=num*(10**digits)
     if num>trunc(num) then num=trunc(num)+1
     else num=trunc(num)
     num=num/(10**digits)
    return num

/** _portsteal_fast v.3 **/
    _portsteal_fast: procedure expose (globals)
     if arg(1,"E") then amount=_stripint(arg(1))
     else amount=0
     if amount="" then amount=0
     if amount<0 then amount=0
     if arg(2,"E") then prod=_stripint(arg(2))
     else prod=3
     if prod\=1 | prod\=2 | prod\=3 then prod=3
    
     prodn=_dword("Fuel Ore;Organics;Equipment",prod,";")
    
     buflen=8*1024
     call zocreceivebuf buflen
     call zocsend "pr^Msz"||prod||amount||"^M"
    
     done=0
     do while \done
      ans=zocwaitmux(" Success!", ,
                     " Busted!", ,
                     " at this port!", ,
                     "You leave the port.")
      line=strip(_lastline())
      select
       when ans=0 & line="You start your droids loading the cargo and Success!" then do
        msg="##SUCCESS##"
        done=1
       end /*when*/
       when ans=1 & line="You start your droids loading the cargo and Suddenly you're Busted!" then do
        msg="##BUST##"
        done=1
       end /*when*/
       when ans=1 & line="Suddenly you're Busted!" then do
        if zocwait("Do you want instructions (Y/N) [N]?")=640 then call _error "timeout"
        msg="##FAKE##"
        done=1
       end /*when*/
       when ans=2 & line="There aren't that many holds of "||prodn||" at this port!" then do
        msg="##HOLDS##"
        done=1
       end /*when*/
       when ans=3 & line="You leave the port." then do
        msg="##ZERO##"
        done=1
       end /*when*/
       when ans=640 then call _error "timeout"
       otherwise nop
      end /*select*/
     end /*do*/
    
     if zocwait("Command [")=640 then call _error "timeout"
     buff=translate(zocreceivebuf(0), "  ", d2c(0)||d2c(10))
     if length(buff)=buflen then call _error "buffer overflow"
    
     exp=0
     amount=0
     avail=0
     holds=0
     fine=0
     turns=9999
    
     /* GET TURNS */
     k=max(pos("<Thievery>",buff),1)
     i=pos("One turn deducted, ",buff,k)+19
     if i>19 then do
      j=pos(" turns left.",buff,i)
      if j>0 then turns=substr(buff,i,j-i)
     end /*if*/
     else j=k
    
     select
      when msg="##SUCCESS##" then do
       i=pos(prodn,buff,j)+11
       j=pos(d2c(13),buff,i)
       parse value substr(buff,i,j-i) with . . avail .
       i=pos("to swipe? [",buff,j)+11
       j=pos(d2c(13),buff,i)
       parse value substr(buff,i,j-i) with holds "] " amount .
       i=pos("and you receive ",buff,j)+16
       if i>16 then j=pos(" experience",buff,i)
       else j=0
       if j>0 then exp=substr(buff,i,j-i)
      end /*when*/
     
      when msg="##BUST##" then do
       i=pos(prodn,buff,j)+11
       j=pos(d2c(13),buff,i)
       parse value substr(buff,i,j-i) with . . avail .
       i=pos("to swipe? [",buff,j)+11
       j=pos(d2c(13),buff,i)
       parse value substr(buff,i,j-i) with holds "] " amount .
       i=pos("fines you ",buff,j)+10
       j=pos(" Cargo Holds",buff,i)
       fine=substr(buff,i,j-i)
       i=pos("and you LOSE ",buff,j)+13
       j=pos(" experience",buff,i)
       exp=substr(buff,i,j-i)
      end /*when*/
    
      when msg="##FAKE##" then do
       i=pos("fines you ",buff,j)+10
       j=pos(" Cargo Holds",buff,i)
       fine=substr(buff,i,j-i)
       i=pos("and you LOSE ",buff,j)+13
       j=pos(" experience",buff,i)
       exp=substr(buff,i,j-i)
      end /*when*/
    
      when msg="##HOLDS##" then do
       i=pos(prodn,buff,j)+11
       j=pos(d2c(13),buff,i)
       parse value substr(buff,i,j-i) with . . avail .
       i=pos("to swipe? [",buff,j)+11
       j=pos(d2c(13),buff,i)
       parse value substr(buff,i,j-i) with holds "] " amount .
       amount=0
      end /*when*/
    
      when msg="##ZERO##" then do
       i=pos(prodn,buff,j)+11
       j=pos(d2c(13),buff,i)
       parse value substr(buff,i,j-i) with . . avail .
       i=pos("to swipe? [",buff,j)+11
       j=pos(d2c(13),buff,i)
       parse value substr(buff,i,j-i) with holds "] " amount .
       amount=0
      end /*when*/
    
      otherwise nop
    
     end /*select*/
    
     rslt=msg||";"||exp||";"||amount||";"||avail||";"||holds||";"||turns||";"||fine
    
    return rslt

/** _bust_memo v.1 **/
    _bust_memo: procedure expose (globals)
     cmd=arg(1)
     sector=arg(2)
     stamp=arg(3)
     msg="REV-CMD : "||cmd||" : "||_pad(sector,5,"R")||" : "||stamp||" ::"
     call zocsend "tt"||msg||"^M^Mq"
     if zocwait("Corporate M.A.I.L. Server.")=640 then call _error "timeout"
     if zocwait("(?=Help)? :")=640 then call _error "timeout"
    return

/** _ini_write v.3 **/
    /*_ v.3 tested -*/
    _ini_write: procedure expose (globals)
     /* argument check */
     do i=1 to 4
      if \arg(i,"E") | arg(i,"O") then call _error "missing arguments in _ini_write."
     end /*do*/
    
     /* name arguments */
     fname=arg(1)
     s=strip(arg(2))
     k=strip(arg(3))
     v=strip(arg(4))
    
     tname=fname||".tmp"
     written=0
     
     rslt=0
     if _fileopenr(fname) then do
      if _fileexists(tname) then if \dosdel(tname) then call _error "file delete failed."
      if _fileopenw(tname) then do
       insection=0
       linenum=0
       do while \_fileeof(fname)
        line=strip(linein(fname))
        linenum=linenum+1
        select
         when line="["||s||"]" then do
          insection=1
          if linenum>1 then call lineout tname, ""
          call lineout tname, line
          call charout tname, k||"="||v
          written=1
         end /*when*/
         when insection & left(line,length(k)+1)=k||"=" then nop
         when insection & left(line,1)="[" then do
          if linenum>1 then call lineout tname, ""
          call charout tname, line
          insection=0
         end /*when*/
         when line="" then do
          if linenum>1 then call lineout tname, ""
          call charout tname, ""
         end /*when*/
         otherwise do
          if linenum>1 then call lineout tname, ""
          call charout tname, line
         end /*otherwise*/
        end /*select*/
       end /*do*/
       if \written then do
        if linenum>1 then call lineout tname, ""
        call lineout tname, "["||s||"]"
        call charout tname, k||"="||v
        written=1
       end /*if*/
       call _fileclose(tname)
      end /*if*/
      call _fileclose(fname)
     end /*if*/
     if written then do
      if \dosdel(fname) then call _error "file delete failed."
      if \dosrename(tname,fname) then call _error "file rename failed."
     end /*if*/
     else do
      if \_fileexists(fname) then do
       if _filenew(fname) then do
        call lineout fname, "["||s||"]"
        call charout fname, k||"="||v
        call _fileclose(fname)
        written=1
       end /*if*/
      end /*if*/
     end /*else*/
    return written

/** _space v.1 **/
    _space: procedure expose (globals)
     str=strip(arg(1))
     if arg(2,"E") then n=arg(2); else n=1
     if arg(3,"E") then pad=arg(3); else pad=" "
     rslt=word(str,1)
     do i=2 to words(str)
      rslt=rslt||copies(pad,n)||word(str,i)
     end /*do*/
    return rslt

/** _instr v.3 **/
    _instr: procedure expose (globals)
     fnd=arg(1)
     str=arg(2)
     if lower(arg(3))\="cs" then do
      fnd=lower(fnd)
      str=lower(str)
     end /*if*/
     if arg(1,"E") & arg(2,"E") & pos(fnd,str)>0 then rslt=1
     else rslt=0
    return rslt

/** _beep v.2 **/
    _beep: procedure expose (globals)
     select
      when arg(1,"O") then call zocwrite d2c(7)
      when _fileexists(arg(1)) then call zocplaysound arg(1)
      otherwise call zocwrite d2c(7)
     end /*select*/
    return

/** _getscriptpath v.1 **/
    _getscriptpath:
     parse value zocgetglobaloption("ScriptPath") with . '="' spath '"'
     spath=dosfname(spath)
     if right(spath,1)\="\" then spath=spath||"\"
     if \dosisdir(spath) then call _error "invalid path in _getscriptpath"
    return spath

/** _ini_getheadings v.5 **/
    _ini_getheadings: procedure expose (globals)
     if arg(1,"E") then fname=arg(1)
     else call _error "missing parameter in _ini_getheadings"
     if arg(2,"E") then delim=left(arg(2),1)
     else delim=";"
     list=""
     if _fileopenr(fname) then do
      do while \_fileeof(fname)
       line=strip(linein(fname))
       if left(line,1)="[" then do
        if list="" then list=strip(translate(line,"  ","[]"))
        else list=list||delim||strip(translate(line,"  ","[]"))
       end /*if*/
      end /*do*/
      call _fileclose fname
     end /*do*/
     if list="" then list="##EOF##"
    return list

/** _drequestlist v.3 **/
    _drequestlist: procedure expose (globals)
     i=zocrequestlist(arg(1),translate(arg(2),"|"||arg(3),arg(3)||"|"))
     select
      when i<0 & lower(arg(4))="c" then call _quit "script cancelled by user.", "nocopy"
      when i<0 then rslt="##CANCEL##"
      otherwise rslt=_dword(arg(2),i+1,arg(3))
     end /*select*/
    return rslt

/** _ini_read v.1 **/
    _ini_read: procedure expose (globals)
     /* argument check */
     do i=1 to 3
      if \arg(i,"E") | arg(i,"O") then call _error "missing arguments in _ini_read."
     end /*do*/
    
     /* name arguments */
     fname=arg(1)
     s=strip(arg(2))
     k=strip(arg(3))
    
     if _fileopenr(fname) then do
      done=0
      found=0
      insection=0
      do while \done & \_fileeof(fname)
       line=strip(linein(fname))
       select
        when left(line,1)=";" then nop
        when line="["||s||"]" then insection=1
        when insection & left(line,1)="[" then done=1
        when insection & left(line,length(k)+1)=k||"=" then do
         v=strip(substr(line,length(k)+2))
         done=1
         found=1
        end /*when*/
        otherwise nop
       end /*select*/
      end /*do*/
      call _fileclose fname 
      if \found then v="##EOF##"
     end /*if*/
     else v="##EOF##"
    
    return v

/** _askint v.2 **/
    _askint: procedure expose (globals)
     do i=1 to 3
      select
       when i=1 & arg(i,"E") then msg=arg(i)
       when i=1              then msg="enter an integer:"
       when i=2 & arg(i,"E") then default=arg(i)
       when i=2              then default=""
       when i=3 & arg(i,"E") then cflag=min(verify(lower(arg(i)),"c","M"),1)
       when i=3              then cflag=0
       otherwise nop
      end /*select*/
     end /*do*/
     rslt=strip(zocask(msg, default))
     do while _stripint(rslt)\=rslt | rslt=""
      default=rslt||" [please enter an integer or ESC to cancel.]"
      if rslt="##CANCEL##" then leave
      else rslt=strip(zocask(msg, default))
     end /*do*/
     if cflag & rslt="##CANCEL##" then call _quit "script cancelled by user.", "nocopy"
    return rslt

/** _askstr v.1 **/
    _askstr: procedure expose (globals)
     do i=1 to 3
      select
       when i=1 & arg(i,"E") then msg=arg(i)
       when i=1              then msg="enter an string:"
       when i=2 & arg(i,"E") then default=arg(i)
       when i=2              then default=""
       when i=3 & arg(i,"E") then cflag=min(verify(lower(arg(i)),"c","M"),1)
       when i=3              then cflag=0
       otherwise nop
      end /*select*/
     end /*do*/
     rslt=zocask(msg, default)
     if cflag & rslt="##CANCEL##" then call _quit "script cancelled by user.", "nocopy"
    return rslt

/** _fileopenw v.3 **/
    _fileopenw: procedure expose (globals)
     if \arg(1,"E") then call _error "missing parameter in _fileopenw"
     if _fileexists(arg(1)) then do
      call stream arg(1), "C", "OPEN WRITE"
      call stream arg(1), "C", "SEEK <0"
      rslt=_fileready(arg(1))
      if \rslt then call _fileclose arg(1)
     end /*if*/
     else rslt=_filenew(arg(1))
    return rslt

/** _fileclose v.3 **/
    _fileclose: procedure expose (globals)
     if \arg(1,"E") then call _error "missing argument in _fileclose"
     call stream arg(1), "C", "CLOSE"
    return

/** _calc_base_date v.3 **/
    /* v.3 tested */
    _calc_base_date: procedure expose (globals)
    
     yr=arg(1); mm=arg(2); dd=arg(3); hr=arg(4); mn=arg(5); sc=arg(6)
    
     /* leapyear? */
        leapyear=abs((yr//4=0)-1)
    
     /* day of year */
        doy=dd-1
        do i=1 to mm-1
         doy=doy+_dword(_monthdays,i,";")
        end /*do*/
        if mm>2 & leapyear then doy=doy+1
    
     /* base day since 2000 */
        base=_baseday.yr-_baseday.2000+doy
    
     /* seconds of day */
        sod=((hr*60)+mn)*60+sc
    
     /* base day in seconds */
        base_sec=base*86400+sod
    
     rslt=base||";"||doy||";"||sod||";"||base_sec
    
    return rslt

/** _fileopenr v.4 **/
    _fileopenr: procedure expose (globals)
     if \arg(1,"E") then call _error "missing parameter in _fileopenr"
     if _fileexists(arg(1)) then do
      call stream arg(1), "C", "OPEN READ"
      rslt=_fileready(arg(1))
      if \rslt then call _fileclose arg(1)
     end /*if*/
     else rslt=0
    return rslt

/** _fileeof v.4 **/
    _fileeof: procedure expose (globals)
     rslt=\lines(arg(1))
    return rslt

/** _mrequestlist v.3 **/
    _mrequestlist: procedure expose (globals)
     do i=1 to 3
      if \arg(i,"E") then call _error "missing parameter in _mrequestlist"
     end /*do*/
     msg=arg(1)
     list=arg(2)
     if list="" then call _error "empty list in _mrequestlist"
     delim=arg(3)
     if arg(4,"E") then mode=arg(4)
                   else mode=""
     if arg(5,"E") then default=arg(5)
                   else default=""
    
     yes="> "
     no="   "
    
     if default="" then do
      rslt=0
      menu="   DONE"||delim||no||_dword(list,1,delim)
      count=_dwords(list,delim)
     end /*if*/
     else do
      rslt=_dword(default,1,delim)
      if rslt then menu="   DONE"||delim||yes||_dword(list,1,delim)
      else menu="   DONE"||delim||no||_dword(list,1,delim)
      count=min(_dwords(list,delim),_dwords(default,delim))
     end /*else*/
    
     if count>1 then do
      do i=2 to count
       if default="" then flag=no
       else do
        if _dword(default,i,delim) then flag=yes
        else flag=no
       end /*else*/
       menu=menu||delim||flag||_dword(list,i,delim)
       if default="" then rslt=rslt||delim||0
       else rslt=rslt||delim||_dword(default,i,delim)
      end /*do*/
     end /*if*/
    
     i=_drequestlisti(msg,menu,delim)
    
     do while i>1
      menu="   DONE"
      temp=""
      do j=1 to _dwords(list,delim)
       if j=(i-1) then do
        if _dword(rslt,j,delim) then do
         menu=menu||delim||no||_dword(list,j,delim)
         if temp="" then temp=0
         else temp=temp||delim||0
        end /*if*/
        else do
         menu=menu||delim||yes||_dword(list,j,delim)
         if temp="" then temp=1
         else temp=temp||delim||1
        end /*else*/
       end /*if*/
       else do
        if temp="" then temp=_dword(rslt,j,delim)
        else temp=temp||delim||_dword(rslt,j,delim)
        if _dword(rslt,j,delim) then menu=menu||delim||yes||_dword(list,j,delim)
        else menu=menu||delim||no||_dword(list,j,delim)
       end /*else*/
      end /*do*/
      rslt=temp
      i=_drequestlisti(msg,menu,delim)
     end /*do*/
    
     if lower(mode)="c" & i=0 then call _quit "script cancelled by user."
    
     dmax=_dwords(default,";")
     lmax=_dwords(list,";")
     if dmax>lmax then do
      do i=dmax+1 to lmax
       rslt=rslt||delim||_dword(default,i,";")
      end /*do*/
     end /*if*/
    
    return rslt

/** _stripcomma v.1 **/
    _stripcomma: procedure expose (globals)
     rslt=translate(_space(translate(arg(1),", "," ,"),0)," ",",")
    return rslt

/** _fileexists v.3 **/
    _fileexists: procedure expose (globals)
     if \arg(1,"E") then call _error "missing parameter in _fileexists"
     if stream(arg(1), "C", "QUERY EXISTS")="" then rslt=0; else rslt=1
    return rslt

/** _filenew v.4 **/
    _filenew: procedure expose (globals)
     if \arg(1,"E") then call _error "missing parameter in _filenew"
     if arg(2,"E") & lower(arg(2))="delete" then call dosdel arg(1)
     if _fileexists(arg(1)) then rslt=0
     else do
      call stream arg(1), "C", "OPEN WRITE"
      rslt=_fileready(arg(1))
      if \rslt then call _fileclose arg(1)
     end /*else*/
    return rslt

/** _fileready v.1 **/
    _fileready: procedure expose (globals)
     if \arg(1,"E") then call _error "missing parameter in _fileready"
     if stream(arg(1), "S")\="NOTREADY" then rslt=1; else rslt=0
    return rslt